home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Demos / demo_gadget < prev    next >
Encoding:
Text File  |  1992-01-06  |  12.8 KB  |  590 lines
  1. \ Demonstrate the use of Amiga Intuition Gadgets.
  2. \
  3. \ This program uses all of the main types of
  4. \ gadgets in a very simple context.
  5. \ The gadgets are built using the simple "SETUP"
  6. \ words provided in the file ju:gadget_support.
  7. \
  8. \ Since gadgets are so flexible, we do not provide a
  9. \ simplified interface like the EZMenu system.
  10. \ This program is, therefore, offered as an example
  11. \ of a gadget program that works.  Study it
  12. \ and enjoy writing your own gadget programs.
  13. \
  14. \ A window is opened and the gadgets drawn.
  15. \ You can draw in the window using the mouse.
  16. \ The Color gadget toggles the drawing color.
  17. \ The Clear gadget clears the window, redraws the
  18. \ gadgets, and reports the state of the two
  19. \ string gadgets.
  20. \
  21. \ Author: Phil Burk
  22. \ Copyright 1988 Phil Burk
  23.  
  24. \ MOD: 02/28/90 - mdh, enhanced to put up a requester with
  25. \                 a string gadget in it.
  26. \ MOD: PLB 12/16/90 Add mutual exclude gadgets example.
  27. \ 00001 PLB 1/6/92 Added drops after RemoveGList() and AddGList()
  28.  
  29. include? boolean.setup ju:gadget_support
  30. include? gr.init ju:amiga_graph
  31. include? ev.getclass ju:amiga_events
  32. include? msec ju:msec
  33. include? { ju:locals
  34. getmodule includes
  35.  
  36. ANEW TASK-DEMO_GADGET
  37. decimal
  38.  
  39. variable LAST-GADGET
  40. : LINK.GADGET  ( gadget -- link this to the previous gadget )
  41.     last-gadget @ ?dup
  42.     IF    over swap s! gg_nextgadget
  43.     THEN
  44.     last-gadget !
  45. ;
  46.  
  47. \ Declare Gadget Structures
  48. \ Color checkbox
  49. gadget CHECKG
  50. intuitext CHECKG-TEXT
  51.  
  52. \ Clear menubutton
  53. gadget MENUG
  54. intuitext MENUG-TEXT
  55.  
  56. \ Requester button
  57. gadget REQG
  58. intuitext REQG-TEXT
  59.  
  60. \ X,Y input device
  61. gadget SLIDERG
  62. propinfo SLIDER-INFO
  63. image MYKNOB  ( for system to initialize )
  64.  
  65. \ Text input gadget
  66. gadget STRINGG
  67. stringinfo STRING-INFO
  68. 256 constant MAX_STR_CHARS
  69. create STR-BUFFER max_str_chars allot
  70. border STRING-BORDER
  71. create STRING-XYS 5 cells allot
  72.  
  73. \ Numeric gadget
  74. gadget INTGAD
  75. stringinfo INTGAD-INFO
  76. create INT-BUFFER 40 allot
  77. \ Border for gadget
  78. border BOOLG-BORDER
  79. create BOOLG-XYS 5 cells allot
  80.  
  81. \ Functions to execute when gadget hit.  The CFA of the word
  82. \ is stored in the gadget data area for automatic execution
  83. \ by PROCESS.GADGET.
  84. \ You could also use CASE statements or other techniques to
  85. \ associate a function with a gadget.
  86. : GAD.STRING ( gadget -- , type string in string gadget)
  87.     s@ gg_specialinfo
  88.     s@ si_buffer
  89.     0count type cr
  90. ;
  91.  
  92. : GAD.INT ( gadget -- , print number in INTGADGET)
  93.     s@ gg_specialinfo
  94.     s@ si_longint . cr
  95. ;
  96.  
  97. : REDRAW ( -- , redraw gadgets in window )
  98.     checkg gr-curwindow @ null refreshgadgets()
  99. ;
  100.  
  101. : DUMP.STUFF ( -- , dump string and integer values )
  102.     stringg gad.string
  103.     intgad gad.int
  104. ;
  105.  
  106. : GAD.CLEAR ( gadget -- , action for clear gadget )
  107.     drop gr.clear
  108.     redraw
  109.     dump.stuff
  110. ;
  111.  
  112. : GAD.COLOR ( gadget -- , change colors for mouse drawing )
  113.     s@ gg_flags SELECTED AND
  114.     IF 3
  115.     ELSE 1
  116.     THEN  gr.color!
  117. ;
  118.  
  119. : GAD.SLIDE ( gadget -- , report new values after change )
  120.     s@ gg_specialinfo
  121.     dup s@ pi_horizpot $ FFFF and .
  122.     s@ pi_vertpot $ FFFF and . cr
  123. ;
  124.  
  125.  
  126. \ ----------------------------------------------------
  127. \ Initialize the gadgets for this test.
  128. : CHECKG.INIT  ( -- , initialize color toggling gadget )
  129.     boolg-xys boolg-border s! bd_xy ( set border )
  130.     52 14 boolg-border border.setup
  131. \
  132.     20 30 50 12 checkg checkbox.setup
  133.     boolg-border checkg s! gg_gadgetrender
  134. \
  135.     checkg-text checkg s! gg_gadgettext
  136.     0" Color" checkg-text itext.setup
  137. \ Set function to be executed when hit.
  138.     ' gad.color checkg s! gg_userdata
  139.     checkg link.gadget
  140. ;
  141.  
  142. : MENUG.INIT ( -- , this gadget Clears the window)
  143.     20 50 50 12 menug menubutton.setup
  144.     boolg-border menug s! gg_gadgetrender
  145. \
  146.     menug-text menug s! gg_gadgettext
  147.     0" Clear" menug-text itext.setup
  148.     ' gad.clear menug s! gg_userdata
  149. \
  150.     menug link.gadget ( link gadgets )
  151. ;
  152.  
  153. defer PUT.UP.REQ
  154.  
  155. : REQG.INIT ( -- , this gadget puts up a requester)
  156.     20 70 50 12 reqg menubutton.setup
  157.     boolg-border reqg s! gg_gadgetrender
  158. \
  159.     reqg-text reqg s! gg_gadgettext
  160.     0"  Req" reqg-text itext.setup
  161.     ' put.up.req reqg s! gg_userdata
  162. \
  163.     reqg link.gadget ( link gadgets )
  164. ;
  165.  
  166. : SLIDERG.INIT ( -- , two dimensional slider gadget )
  167.     100 30 50 50 sliderg propgadget.setup
  168.     ' gad.slide sliderg s! gg_userdata
  169.     9000 2000 1000 1000 slider-info propinfo.setup
  170.     slider-info sliderg s! gg_specialinfo
  171.     myknob sliderg s! gg_gadgetrender
  172. \
  173.     sliderg link.gadget
  174. ;
  175.  
  176. : STRINGG.INIT ( -- , string gadget )
  177.     250 30 200 14 stringg stringgadget.setup
  178.     ' gad.string stringg s! gg_userdata
  179. \
  180.     str-buffer max_str_chars erase
  181.     $ 41424300 str-buffer !
  182.     str-buffer 20 string-info stringinfo.setup
  183.     string-info stringg s! gg_specialinfo
  184.     string-border stringg s! gg_gadgetrender
  185.     string-xys string-border s! bd_xy
  186.     202 16 string-border border.setup
  187. \
  188.     stringg link.gadget
  189. ;
  190.  
  191. : INTGAD.INIT ( -- )
  192.     250 80 200 14 intgad intgadget.setup
  193.     ' gad.int intgad s! gg_userdata
  194. \
  195.     int-buffer 40 erase
  196.     $ 30000000 int-buffer !
  197.     int-buffer 20 intgad-info stringinfo.setup
  198.     intgad-info  intgad s! gg_specialinfo
  199. \ STRING-BORDER setup in STRINGG.INIT
  200.     string-border  intgad s! gg_gadgetrender
  201. \
  202.     intgad link.gadget
  203. ;
  204.  
  205.  
  206. : PROCESS.GADGET  ( gadget -- , execute CFA in gadget)
  207.     dup s@ gg_userdata ?dup
  208.     IF execute
  209.     ELSE drop ." NO CFA!"
  210.     THEN
  211. ;
  212.  
  213. VARIABLE IF-DOWN
  214. VARIABLE IF-QUIT
  215.  
  216. newwindow GADWINDOW
  217.  
  218. \ ---------------- Requester stuff
  219.  
  220. .NEED InitRequester()
  221. : InitRequester()   ( req -- )
  222.     callvoid>abs intuition_lib InitRequester
  223. ;
  224. .THEN
  225.  
  226. .NEED Request()
  227. : Request()   ( req window -- flag , false = failure )
  228.     call>abs intuition_lib Request  0= 0=
  229. ;
  230. .THEN
  231.  
  232. .NEED EndRequest()
  233. : EndRequest()   ( req window -- )
  234.     callvoid>abs intuition_lib EndRequest
  235. ;
  236. .THEN
  237.  
  238. requester RQ
  239.  
  240. : RQ.CLOSE  ( -- )
  241.     gad.string
  242.     rq  gr-curwindow @    EndRequest()
  243. ;
  244.  
  245. \ Text input gadget
  246. gadget STRINGRG
  247. stringinfo STRING-INFO2
  248. create STR-BUFFER2 max_str_chars allot
  249. border STRING-BORDER2
  250. create STRING-XYS2 5 cells allot
  251.  
  252. : STRINGRG.INIT ( -- , string gadget )
  253.     20 20 160 8 stringrg stringgadget.setup
  254.     stringrg s@ gg_GadgetType REQGADGET | stringrg s! gg_GadgetType
  255.     ' RQ.CLOSE stringrg s! gg_userdata
  256. \
  257.     str-buffer2 max_str_chars erase
  258.     $ 44454600 str-buffer2   !
  259.     str-buffer2 20 string-info2 stringinfo.setup
  260.     string-info2 stringrg s! gg_specialinfo
  261.     string-border2 stringrg s! gg_gadgetrender
  262.     string-xys2 string-border2 s! bd_xy
  263.     162 10 string-border2 border.setup
  264. \
  265. ;
  266.  
  267. : RQ.INIT  ( -- )
  268.     stringrg.init
  269. \
  270. \ fill it with initial values...
  271.     RQ InitRequester()
  272. \
  273.     20 20 200 50  ( -- l t w h )
  274.         RQ s! rq_height
  275.         RQ s! rq_width
  276.         RQ s! rq_topedge
  277.         RQ s! rq_leftedge
  278.     2 RQ s! rq_backfill
  279.     stringrg  RQ s! rq_ReqGadget
  280. ;
  281.  
  282. : RQ.ACTIVATE  ( -- )
  283.     STRINGRG   gr-curwindow @  RQ   ActivateGadget()
  284. ;
  285.  
  286. : RQ.DISPLAY  ( gadget -- present requester )
  287.     drop   RQ  gr-curwindow @   Request()  drop
  288. ;
  289. ' rq.display is put.up.req
  290.  
  291. \ ---------------- End of Requester stuff
  292.  
  293. \ ---------------- Begin Mutual Exclude Example
  294. \ Mutual Exclude Gadgets are tricky.
  295. \ Please see the Amiga ROM/KERNEL Reference Manual V1.3 or later.
  296. \ There is also an article in AmigaMail for developers, IV-23.
  297. \
  298. \ If you want to manually select or deselect a gadget, you must:
  299. \ Remove using RemoveGList(), change SELECTED bit, then add back
  300. \ using AddGList(), then draw using RefreshGList().
  301. \
  302. \ This image data was generated by drawing two brushes
  303. \ with DeluxePaint, then converting them to source code using
  304. \ JA:DUMPBRUSH.F cloned.
  305.  
  306. image ON-IMAGE
  307. 48 on-image s! ig_width
  308. 15 on-image s! ig_height
  309. 2 on-image s! ig_depth
  310. 3  on-image s! ig_planepick
  311.  
  312. create on-image-DATA here HEX
  313. \ Plane 0
  314.     FFFE w, 0003 w, FFF8 w,
  315.     FFC0 w, 0000 w, 1FF8 w,
  316.     FE00 w, 0000 w, 03F8 w,
  317.     F800 w, 0000 w, 00F8 w,
  318.     F000 w, 0000 w, 00F8 w,
  319.     E000 w, 0000 w, 0038 w,
  320.     C000 w, 0000 w, 0018 w,
  321.     C000 w, 0000 w, 0018 w,
  322.     C000 w, 0000 w, 0018 w,
  323.     E000 w, 0000 w, 0038 w,
  324.     F800 w, 0000 w, 0078 w,
  325.     F800 w, 0000 w, 00F8 w,
  326.     FE00 w, 0000 w, 03F8 w,
  327.     FFC0 w, 0000 w, 1FF8 w,
  328.     FFFE w, 0003 w, FFF8 w,
  329.  
  330. \ Plane 1
  331.     8001 w, FFFC w, 0000 w,
  332.     603F w, FFFF w, E008 w,
  333.     11FF w, FFFF w, FC30 w,
  334.     0FFF w, FFFF w, FF40 w,
  335.     0FFF w, FFFF w, FF80 w,
  336.     1FFF w, FFFF w, FFC0 w,
  337.     3FFF w, FFFF w, FFE0 w,
  338.     3FFF w, FFFF w, FFE0 w,
  339.     3FFF w, FFFF w, FFE0 w,
  340.     1FFF w, FFFF w, FFC0 w,
  341.     0FFF w, FFFF w, FF80 w,
  342.     17FF w, FFFF w, FF80 w,
  343.     21FF w, FFFF w, FC60 w,
  344.     403F w, FFFF w, E018 w,
  345.     8001 w, FFFC w, 0000 w,
  346.  
  347. here swap - constant ON_IMAGE_SIZE   DECIMAL
  348. \ Copy image data to CHIP RAM before using!
  349.  
  350. image OFF-IMAGE
  351. 48 off-image s! ig_width
  352. 15 off-image s! ig_height
  353. 2 off-image s! ig_depth
  354. 2  off-image s! ig_planepick
  355.  
  356. create off-image-DATA here HEX
  357.  
  358. \ Plane 1
  359.     0001 w, FFFC w, 0000 w,
  360.     003F w, FFFF w, E000 w,
  361.     01FF w, FFFF w, FC00 w,
  362.     07FF w, FFFF w, FF00 w,
  363.     0FFF w, FFFF w, FF80 w,
  364.     1FFF w, FFFF w, FFC0 w,
  365.     3FFF w, FFFF w, FFE0 w,
  366.     3FFF w, FFFF w, FFE0 w,
  367.     3FFF w, FFFF w, FFE0 w,
  368.     1FFF w, FFFF w, FFC0 w,
  369.     0FFF w, FFFF w, FF80 w,
  370.     07FF w, FFFF w, FF00 w,
  371.     01FF w, FFFF w, FC00 w,
  372.     003F w, FFFF w, E000 w,
  373.     0001 w, FFFC w, 0000 w,
  374.  
  375. here swap - constant OFF_IMAGE_SIZE   DECIMAL
  376. \ Copy image data to CHIP RAM before using!
  377.  
  378.  
  379. : SETUP.IMAGES ( -- )
  380. \ copy image date to CHIP RAM
  381.     MEMF_CHIP on_image_size allocblock ?dup
  382.     IF
  383.         on-image-data over on_image_size cmove
  384.         on-image s! ig_imageData
  385.     THEN
  386. \
  387. \ copy image date to CHIP RAM
  388.     MEMF_CHIP off_image_size allocblock ?dup
  389.     IF
  390.         off-image-data over off_image_size cmove
  391.         off-image s! ig_imageData
  392.     THEN
  393. ;
  394.  
  395. : FREE.IMAGES
  396.     on-image s@ ig_imagedata ?dup
  397.     IF
  398.         freeblock
  399.         0 on-image s! ig_imagedata
  400.     THEN
  401. \
  402.     off-image s@ ig_imagedata ?dup
  403.     IF
  404.         freeblock
  405.         0 off-image s! ig_imagedata
  406.     THEN
  407. ;
  408.  
  409. gadget RADIOG1
  410. intuitext RADIOG1-TEXT
  411.  
  412. gadget RADIOG2
  413. intuitext RADIOG2-TEXT
  414.  
  415. gadget RADIOG3
  416. intuitext RADIOg3-TEXT
  417.  
  418. variable CUR-STATION
  419.  
  420. : DESELECT.GADGET  ( gadget -- , deselect a gadget )
  421.     dup s@ gg_flags
  422.     SELECTED COMP AND  ( mask off selected bit )
  423.     swap s! gg_flags
  424. ;
  425.  
  426. : SELECT.GADGET  ( gadget -- , select a gadget )
  427.     dup s@ gg_flags
  428.     SELECTED OR  ( mask ON selected bit )
  429.     swap s! gg_flags
  430. ;
  431.  
  432. : SELECT.STATION  ( gadget -- , turn off current, turn on this one )
  433.     gr-curwindow @ radiog1 3 RemoveGList() drop \ 00001
  434.     cur-station @ deselect.gadget
  435.     dup  select.gadget
  436.     cur-station !
  437.     gr-curwindow @ radiog1 -1 3 0 AddGList() drop \ 00001
  438.     radiog1 gr-curwindow @ 0 3 refreshGList()
  439. ;
  440.  
  441. : GAD.KPFA  ( gadget -- , select the best radio station )
  442.     select.station ." KPFA" cr
  443. ;
  444. : GAD.KLAW  ( gadget -- , select another radio station )
  445.     select.station ." KLAW" cr
  446. ;
  447. : GAD.KQED  ( gadget -- , select another radio station )
  448.     select.station ." KQED" cr
  449. ;
  450.  
  451.  
  452. : SETUP.RADIO  { xpos cfa 0text itext gad -- , setup gadget }
  453. \ specify x,y,w,h and set other defaults
  454.     xpos 100 48 15 gad menubutton.setup
  455. \
  456. \ use separate images for on and off
  457.     off-image gad s! gg_GADGETrender
  458.     on-image gad s! gg_SELECTrender
  459.     GADGHIMAGE GADGIMAGE | gad s! gg_flags
  460. \
  461. \ setup IntuiText structure
  462.     itext gad s! gg_gadgettext
  463.     0text itext itext.setup
  464.     6 itext s! it_leftedge
  465.     4 itext s! it_topedge
  466. \
  467. \ function to be called in our event loop
  468.     cfa gad s! gg_userdata
  469.     gad link.gadget
  470. ;
  471.  
  472. : SETUP.RADIO.ALL  ( -- )
  473.     50 'c gad.kpfa
  474.     0" KPFA" radiog1-text radiog1 setup.radio
  475. \
  476. \ Make KPFD the default.
  477.     radiog1 cur-station !
  478.     GADGHIMAGE GADGIMAGE | SELECTED | radiog1 s! gg_flags
  479. \
  480. \ Now setup other two options.
  481.     110 'c gad.kqed
  482.     0" KQED" radiog2-text radiog2 setup.radio
  483. \
  484.     170 'c gad.klaw
  485.     0" KLAW" radiog3-text radiog3 setup.radio
  486. ;
  487.  
  488. \ ---------------- End Mutual Exclude Example
  489.  
  490. : PROCESS.EVENT ( class -- done? , process events from IDCMP )
  491.     false if-quit !
  492.     CASE
  493.         MOUSEBUTTONS OF   ( check for up or down )
  494.             ev-last-code @ SELECTDOWN =
  495.             IF  true if-down !
  496.                 ev.getxy00 gr.move  ( MOVE graphics pen to down x,y )
  497.             ELSE false if-down !
  498.             THEN
  499.         ENDOF
  500.  
  501.         MOUSEMOVE OF if-down @
  502.             IF  ev.getxy00 gr.draw
  503.             THEN
  504.         ENDOF  ( DRAW )
  505.  
  506.         GADGETUP OF ev-last-iaddress @ ( -- gadget )
  507.             >rel process.gadget
  508.         ENDOF
  509.  
  510.     GADGETDOWN OF ev-last-iaddress @
  511.         >rel process.gadget
  512.     ENDOF
  513.  
  514.     REQSET OF RQ.ACTIVATE
  515.         ENDOF
  516.  
  517.     CLOSEWINDOW OF true if-quit ! ENDOF
  518.  
  519.     ." GADGET.LOOP -- Unrecognized event!" cr
  520.     ENDCASE
  521.     if-quit @
  522. ;
  523.  
  524. : GADGET.LOOP  ( -- , loop until done )
  525.     BEGIN
  526.         gr-curwindow @ ev.wait
  527.         gr-curwindow @ ev.getclass dup
  528.         IF process.event
  529.         THEN
  530.     UNTIL
  531. ;
  532.  
  533. : TG.TERM
  534.     gr.closecurw
  535.     free.images
  536.     gr.term
  537. ;
  538.  
  539. : TG.INIT ( -- , initialize demo )
  540. \ Create window from template and make it the current window.
  541.     gr.init
  542.     last-gadget off
  543.     checkg.init
  544.     menug.init
  545.     reqg.init
  546.     sliderg.init
  547.     stringg.init
  548.     intgad.init
  549.     rq.init
  550.     setup.images
  551.     setup.radio.all
  552.     0 if-down !
  553. \
  554. \ Set defaults for newwindow
  555.     GADWINDOW newwindow.setup
  556. \
  557. \ Link to gadget list.
  558.     checkg  gadwindow s! nw_firstgadget
  559. \
  560. \ Set new title.
  561.     0" Gadgets!"  GADWindow s! nw_title
  562. \
  563. \ Add flags for gadget events.
  564.     CLOSEWINDOW MOUSEBUTTONS |  MOUSEMOVE |   ( add MOUSEMOVE )
  565.     GADGETUP | GADGETDOWN |  REQSET |
  566.     GadWindow s! nw_idcmpflags
  567. \
  568.     gadwindow gr.opencurw dup
  569.     IF 400 msec  stringg gr-curwindow @ 0 ActivateGadget()
  570.     ELSE ." COuld not open window!" cr
  571.     THEN
  572. ;
  573.  
  574. : TG.LOOP
  575.     20 20 " Paint in window and play with gadgets." gr.xytext
  576.     1 gr.color!
  577.     gadget.loop
  578. ;
  579. \
  580. : DEMO.GADGETS  ( -- )
  581.     >newline ." GADGETS - Hit CLOSEBOX to stop!" cr
  582. \
  583.     tg.init
  584.     IF  tg.loop
  585.     THEN
  586.     tg.term
  587. ;
  588.  
  589. cr ." Enter:   DEMO.GADGETS   to see demo!" cr
  590.